home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / compiler / sparc / insts.lisp < prev    next >
Encoding:
Text File  |  1992-05-19  |  29.3 KB  |  995 lines
  1. ;;; -*- Package: SPARC -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the Spice Lisp project at
  5. ;;; Carnegie-Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of Spice Lisp, please contact
  7. ;;; Scott Fahlman (FAHLMAN@CMUC). 
  8. ;;; **********************************************************************
  9. ;;;
  10. ;;; $Header: insts.lisp,v 1.8 92/03/06 11:01:37 wlott Exp $
  11. ;;;
  12. ;;; Description of the SPARC architecture.
  13. ;;;
  14. ;;; Written by William Lott
  15. ;;;
  16.  
  17. (in-package "SPARC")
  18. (use-package "ASSEM")
  19. (use-package "EXT")
  20. (use-package "C")
  21.  
  22. (disassem:set-disassem-params
  23.  :instruction-alignment 32
  24.  :storage-class-sets '((register any-reg descriptor-reg base-character-reg
  25.                  sap-reg signed-reg unsigned-reg
  26.                  non-descriptor-reg interior-reg)
  27.                (float-reg single-reg double-reg)
  28.                (control-stack control-stack)
  29.                (number-stack signed-stack unsigned-stack
  30.                      base-character-stack sap-stack
  31.                      single-stack double-stack))
  32.  )
  33.  
  34.  
  35. ;;;; Special argument types and fixups.
  36.  
  37. (defvar *disassem-use-lisp-reg-names* t)
  38.  
  39. (defconstant reg-symbols
  40.   (map 'vector
  41.        #'(lambda (name)
  42.        (cond ((null name) nil)
  43.          (t (make-symbol (concatenate 'string "%" name)))))
  44.        *register-names*))
  45.  
  46. (define-argument-type reg
  47.   :type '(and tn
  48.           (satisfies (lambda (object)
  49.                (or (eq (sc-name (tn-sc object)) 'null)
  50.                    (eq (sc-name (tn-sc object)) 'zero)
  51.                    (eq (sb-name (sc-sb (tn-sc object)))
  52.                    'registers)))))
  53.   :function (lambda (tn)
  54.           (case (sc-name (tn-sc tn))
  55.         (null null-offset)
  56.         (zero 0)
  57.         (t (tn-offset tn))))
  58.   :disassem-printer #'(lambda (value stream dstate)
  59.             (declare (stream stream) (fixnum value))
  60.             (let ((regname (aref reg-symbols value)))
  61.               (princ regname stream)
  62.               (disassem:maybe-note-associated-storage-ref
  63.                value
  64.                'register
  65.                regname
  66.                dstate)))
  67.   )
  68.  
  69. (defconstant float-reg-symbols
  70.   (coerce 
  71.    (loop for n from 0 to 31 collect (make-symbol (format nil "%F~d" n)))
  72.    'vector))
  73.  
  74. (define-argument-type fp-reg
  75.   :type '(and tn
  76.           (satisfies (lambda (object)
  77.                (eq (sb-name (sc-sb (tn-sc object)))
  78.                    'float-registers))))
  79.   :function tn-offset
  80.   :disassem-printer #'(lambda (value stream dstate)
  81.             (declare (stream stream) (fixnum value))
  82.             (let ((regname (aref float-reg-symbols value)))
  83.               (princ regname stream)
  84.               (disassem:maybe-note-associated-storage-ref
  85.                value
  86.                'float-reg
  87.                regname
  88.                dstate)))
  89.   )
  90.  
  91. (define-argument-type odd-fp-reg
  92.   :type '(and tn
  93.           (satisfies (lambda (object)
  94.                (eq (sb-name (sc-sb (tn-sc object)))
  95.                    'float-registers))))
  96.   :function (lambda (tn) (1+ (tn-offset tn))))
  97.  
  98.  
  99. (define-argument-type relative-label
  100.   :type 'label
  101.   :function (lambda (label)
  102.           (ash (- (label-position label) *current-position*) -2))
  103.   :sign-extend t
  104.   :disassem-use-label #'(lambda (value dstate)
  105.               (declare (type disassem:disassem-state dstate))
  106.               (+ (ash value 2) (disassem:dstate-curpos dstate))))
  107.  
  108.  
  109. (eval-when (compile eval load)
  110.   (defconstant branch-conditions
  111.     '(:f :eq :le :lt :leu :ltu :n :vs :t :ne :gt :ge :gtu :geu :p :vc)))
  112.  
  113. ;;; Note that these aren't the standard names for branch-conditions, I think
  114. ;;; they're a bit more readable (e.g., "eq" instead of "e").  You could just
  115. ;;; put a vector of the normal ones here too.
  116. (defconstant branch-cond-name-vec
  117.   (coerce branch-conditions 'vector))
  118.  
  119. (define-argument-type branch-condition
  120.   :type '(member . #.branch-conditions)
  121.   :function (lambda (cond) (position cond branch-conditions))
  122.   :disassem-printer branch-cond-name-vec)
  123.  
  124. (defconstant branch-cond-true
  125.   #b1000)
  126.  
  127. (eval-when (compile eval load)
  128.   (defconstant branch-fp-conditions
  129.     '(:f :ne :lg :ul :l :ug :g :u :t :eq :ue :ge :uge :le :ule :o)))
  130.  
  131. (defconstant branch-fp-cond-name-vec
  132.   (coerce branch-fp-conditions 'vector))
  133.  
  134. (define-argument-type branch-fp-condition
  135.   :type '(member . #.branch-fp-conditions)
  136.   :function (lambda (fp-cond) (position fp-cond branch-fp-conditions))
  137.   :disassem-printer branch-fp-cond-name-vec)
  138.  
  139.  
  140. (define-fixup-type :call :disassem-use-label t)
  141. (define-fixup-type :sethi
  142.   :disassem-printer #'(lambda (value stream dstate)
  143.             (declare (ignore dstate))
  144.             (format stream "%hi(#x~8,'0x)" (ash value 10))))
  145. (define-fixup-type :add)
  146.  
  147.  
  148.  
  149. ;;;; Formats:
  150.  
  151. (define-format (format-1 32
  152.         :disassem-printer '(:name :tab disp))
  153.   (op (byte 2 30) :default 1)
  154.   (disp (byte 30 0) :default-type (unsigned-byte 30)))
  155.  
  156.  
  157. (define-format (format-2-immed 32
  158.         :disassem-printer '(:name :tab immed ", " rd))
  159.   (op (byte 2 30) :default 0)
  160.   (rd (byte 5 25) :default-type reg)
  161.   (op2 (byte 3 22))
  162.   (immed (byte 22 0) :default-type (signed-byte 22)))
  163.  
  164. (defconstant branch-printer
  165.   `(:name (:unless (:constant ,branch-cond-true) cond)
  166.       (:unless (a :constant 0) "," 'A)
  167.       :tab
  168.       disp))
  169.  
  170. (define-format (format-2-branch 32 :disassem-printer branch-printer)
  171.   (op (byte 2 30) :default 0)
  172.   (a (byte 1 29))
  173.   (cond (byte 4 25) :default-type branch-condition)
  174.   (op2 (byte 3 22))
  175.   (disp (byte 22 0) :default-type relative-label))
  176.  
  177. (define-format (format-2-unimp 32
  178.         :disassem-printer '(:name :tab data))
  179.   (op (byte 2 30) :default 0)
  180.   (ignore (byte 5 25) :default 0)
  181.   (op2 (byte 3 22) :default 0)
  182.   (data (byte 22 0) :default-type (unsigned-byte 22)))
  183.  
  184. (defconstant f3-printer
  185.   '(:name :tab
  186.       (:unless (:same-as rd) rs1 ", ")
  187.       (:choose rs2 immed) ", "
  188.       rd))
  189.  
  190. (define-format (format-3-reg 32 :disassem-printer f3-printer)
  191.   (op (byte 2 30))
  192.   (rd (byte 5 25) :default-type reg)
  193.   (op3 (byte 6 19))
  194.   (rs1 (byte 5 14) :default-type reg)
  195.   (i (byte 1 13) :default 0)
  196.   (asi (byte 8 5) :default 0)
  197.   (rs2 (byte 5 0) :default-type reg))
  198.  
  199. (define-format (format-3-immed 32 :disassem-printer f3-printer)
  200.   (op (byte 2 30))
  201.   (rd (byte 5 25) :default-type reg)
  202.   (op3 (byte 6 19))
  203.   (rs1 (byte 5 14) :default-type reg)
  204.   (i (byte 1 13) :default 1)
  205.   (immed (byte 13 0) :default-type (signed-byte 13)))
  206.  
  207. (define-format (format-3-fpop 32
  208.         :disassem-printer
  209.           '(:name :tab (:unless (:same-as rd) rs1 ", ") rs2 ", " rd))
  210.   (op (byte 2 30))
  211.   (rd (byte 5 25) :default-type fp-reg)
  212.   (op3 (byte 6 19))
  213.   (rs1 (byte 5 14) :default-type fp-reg)
  214.   (opf (byte 9 5))
  215.   (rs2 (byte 5 0) :default-type fp-reg))
  216.  
  217.  
  218.  
  219. ;;;; Instructions.
  220.  
  221.  
  222.  
  223. (eval-when (compile eval)
  224.  
  225. ;;; have to do this because defconstant is evalutated in the null lex env.
  226. (defmacro with-ref-format (printer)
  227.   `(let* ((i-or-r
  228.        '(:choose immed rs2))
  229.       (ref-format
  230.        `("[" rs1 (:unless (:constant 0) "+" ,i-or-r) "]"
  231.          (:choose (:unless (:constant 0) asi) nil))))
  232.      ,printer))
  233.  
  234. (defconstant load-printer
  235.   (with-ref-format `(:NAME :TAB ,ref-format ", " rd)))
  236. (defconstant store-printer
  237.   (with-ref-format `(:NAME :TAB rd ", " ,ref-format)))
  238.  
  239. (defmacro define-f3-inst (name op op3 &key (dest-kind 'reg) fixup load-store disassem-printer)
  240.   `(define-instruction (,name
  241.             ,@(if disassem-printer
  242.                   `(:disassem-printer ,disassem-printer)
  243.                   (case load-store
  244.                 ((:load t) ; note that the sun notation for
  245.                     ; things (like swap) that do both is
  246.                     ; like a load
  247.                  `(:disassem-printer ',load-printer))
  248.                 (:store
  249.                  `(:disassem-printer ',store-printer)))))
  250.      (format-3-reg (op :constant ,op)
  251.            (rd :argument ,dest-kind)
  252.            (op3 :constant ,op3)
  253.            (rs1 :argument reg)
  254.            (rs2 :argument reg))
  255.      ,(if (not load-store)
  256.       `(format-3-reg (op :constant ,op)
  257.              (rd :argument ,dest-kind)
  258.              (op3 :constant ,op3)
  259.              (rs1 :same-as rd)
  260.              (rs2 :argument reg))
  261.       `(format-3-immed (op :constant ,op)
  262.                (rd :argument ,dest-kind)
  263.                (op3 :constant ,op3)
  264.                (rs1 :argument reg)
  265.                (immed :constant 0)))
  266.      (format-3-immed (op :constant ,op)
  267.              (rd :argument ,dest-kind)
  268.              (op3 :constant ,op3)
  269.              (rs1 :argument reg)
  270.              (immed :argument (signed-byte 13)))
  271.      (format-3-immed (op :constant ,op)
  272.              (rd :argument ,dest-kind)
  273.              (op3 :constant ,op3)
  274.              (rs1 :same-as rd)
  275.              (immed :argument (signed-byte 13)))
  276.      ,@(when (or load-store fixup)
  277.      `((format-3-immed (op :constant ,op)
  278.                (rd :argument ,dest-kind)
  279.                (op3 :constant ,op3)
  280.                (rs1 :argument reg)
  281.                (immed :argument add-fixup))
  282.        (format-3-immed (op :constant ,op)
  283.                (rd :argument ,dest-kind)
  284.                (op3 :constant ,op3)
  285.                (rs1 :same-as rd)
  286.                (immed :argument add-fixup))))))
  287.  
  288. (setf (macro-function 'define-f3-inst)
  289.       (compile nil (function-lambda-expression
  290.             (macro-function 'define-f3-inst))))
  291.  
  292. ) ; eval-when
  293.  
  294. (define-f3-inst ldsb #b11 #b001001 :load-store :load)
  295. (define-f3-inst ldsh #b11 #b001010 :load-store :load)
  296. (define-f3-inst ldub #b11 #b000001 :load-store :load)
  297. (define-f3-inst lduh #b11 #b000010 :load-store :load)
  298.  
  299. ;;; ----------------------------------------------------------------
  300. (define-f3-inst ld #b11 #b000000 :load-store :load)
  301.  
  302. (defun note-niss-ref (chunk inst stream dstate)
  303.   (when stream
  304.     (disassem:maybe-note-nil-indexed-symbol-slot-ref
  305.      (disassem:arg-value 'immed chunk inst)
  306.      dstate)))
  307.  
  308. (defun note-control-stack-var-ref (chunk inst stream dstate)
  309.   (when stream
  310.     (disassem:maybe-note-single-storage-ref
  311.      (/ (disassem:arg-value 'immed chunk inst) word-bytes)
  312.      'control-stack
  313.      dstate))
  314.   )
  315.  
  316. (defun note-number-stack-var-ref (chunk inst stream dstate)
  317.   (when stream
  318.     (disassem:maybe-note-single-storage-ref
  319.      (/ (disassem:arg-value 'immed chunk inst) word-bytes)
  320.      'number-stack
  321.      dstate))
  322.   )
  323.  
  324. (disassem:specialize (ld
  325.               :disassem-control
  326.                 #'(lambda (chunk inst stream dstate)
  327.                 (when stream
  328.                   (disassem:note-code-constant
  329.                    (disassem:arg-value 'immed chunk inst)
  330.                    dstate))))
  331.   immed
  332.   (rs1 :constant code-offset))
  333.  
  334. (disassem:specialize (ld :disassem-control #'note-niss-ref)
  335.   immed
  336.   (rs1 :constant null-offset))
  337.  
  338. (disassem:specialize (ld :disassem-control #'note-control-stack-var-ref)
  339.   immed
  340.   (rs1 :constant cfp-offset))
  341.  
  342. (disassem:specialize (ld :disassem-control #'note-number-stack-var-ref)
  343.   immed
  344.   (rs1 :constant nfp-offset))
  345.  
  346. ;;; ----------------------------------------------------------------
  347.  
  348. (define-f3-inst ldd #b11 #b000011 :load-store :load)
  349. (disassem:specialize (ldd :disassem-control #'note-number-stack-var-ref)
  350.   immed
  351.   (rs1 :constant nfp-offset))
  352.  
  353. (define-f3-inst ldf #b11 #b100000 :dest-kind fp-reg :load-store :load)
  354. (disassem:specialize (ldf :disassem-control #'note-number-stack-var-ref)
  355.   immed
  356.   (rs1 :constant nfp-offset))
  357.  
  358. (define-f3-inst ldf-odd #b11 #b100000 :dest-kind odd-fp-reg :load-store :load)
  359. (define-f3-inst lddf #b11 #b100011 :dest-kind fp-reg :load-store :load)
  360. (disassem:specialize (lddf :disassem-control #'note-number-stack-var-ref)
  361.   immed
  362.   (rs1 :constant nfp-offset))
  363.  
  364. (define-f3-inst stb #b11 #b000101 :load-store :store)
  365. (define-f3-inst sth #b11 #b000110 :load-store :store)
  366.  
  367. ;;; ----------------------------------------------------------------
  368. (define-f3-inst st #b11 #b000100 :load-store :store)
  369.  
  370. (disassem:specialize (st :disassem-control #'note-niss-ref)
  371.   immed
  372.   (rs1 :constant null-offset))
  373.  
  374. (disassem:specialize (st :disassem-control #'note-control-stack-var-ref)
  375.   immed
  376.   (rs1 :constant cfp-offset))
  377.  
  378. (disassem:specialize (st :disassem-control #'note-number-stack-var-ref)
  379.   immed
  380.   (rs1 :constant nfp-offset))
  381. ;;; ----------------------------------------------------------------
  382.  
  383. (define-f3-inst std #b11 #b000111 :load-store :store)
  384. (disassem:specialize (std :disassem-control #'note-number-stack-var-ref)
  385.   immed
  386.   (rs1 :constant nfp-offset))
  387.  
  388. (define-f3-inst stf #b11 #b100100 :dest-kind fp-reg :load-store :store)
  389. (disassem:specialize (stf :disassem-control #'note-number-stack-var-ref)
  390.   immed
  391.   (rs1 :constant nfp-offset))
  392.  
  393. (define-f3-inst stf-odd #b11 #b100100 :dest-kind odd-fp-reg :load-store :store)
  394. (define-f3-inst stdf #b11 #b100111 :dest-kind fp-reg :load-store :store)
  395. (disassem:specialize (stdf :disassem-control #'note-number-stack-var-ref)
  396.   immed
  397.   (rs1 :constant nfp-offset))
  398.  
  399. (define-f3-inst ldstub #b11 #b001101 :load-store t)
  400. (define-f3-inst swap #b11 #b001111 :load-store t)
  401.  
  402. (define-instruction (ldfsr)
  403.   (format-3-immed (op :constant #b11)
  404.           (rd :constant 0)
  405.           (op3 :constant #b100001)
  406.           (rs1 :argument reg)
  407.           (immed :argument (signed-byte 13))))
  408.  
  409. (define-instruction (stfsr)
  410.   (format-3-immed (op :constant #b11)
  411.           (rd :constant 0)
  412.           (op3 :constant #b100101)
  413.           (rs1 :argument reg)
  414.           (immed :argument (signed-byte 13))))
  415.  
  416. ;;; ----------------------------------------------------------------
  417. (define-f3-inst add #b10 #b000000 :fixup t)
  418.  
  419. (defstruct sethi-note
  420.   target-reg
  421.   high-bits
  422.   following-addr)
  423.  
  424. (defun look-at-sethi-note (chunk inst stream dstate)
  425.   (when stream
  426.     (let ((sethi-note (disassem:dstate-get-prop dstate 'sethi-note)))
  427.       (when (and sethi-note
  428.          (= (disassem:dstate-curpos dstate)
  429.             (sethi-note-following-addr sethi-note))
  430.          (= (disassem:arg-value 'rs1 chunk inst)
  431.             (sethi-note-target-reg sethi-note)))
  432.     (let ((value
  433.            (+ (sethi-note-high-bits sethi-note)
  434.           (disassem:arg-value 'immed
  435.                       chunk inst))))
  436.     (or (disassem:maybe-note-assembler-routine value dstate)
  437.         (disassem:note #'(lambda (stream)
  438.                    (format stream "#x~x (~d)"
  439.                        value
  440.                        (disassem:sign-extend value 32)))
  441.                dstate))))))) 
  442.  
  443. (disassem:specialize (add :disassem-control #'look-at-sethi-note)
  444.   immed)
  445.  
  446. ;;; note: this must be after the above, because the disassem-controls
  447. ;;; are exclusive
  448. (disassem:specialize (add
  449.               :disassem-control
  450.                 #'(lambda (chunk inst stream dstate)
  451.                 (when stream
  452.                   (disassem:maybe-note-nil-indexed-object
  453.                    (disassem:arg-value 'immed chunk inst)
  454.                    dstate))))
  455.   immed
  456.   (rs1 :constant null-offset))
  457. ;;; ----------------------------------------------------------------
  458.  
  459. (define-f3-inst addcc #b10 #b010000)
  460. (define-f3-inst addx #b10 #b001000)
  461. (define-f3-inst addxcc #b10 #b011000)
  462.  
  463. (define-f3-inst taddcc #b10 #b100000)
  464. (define-f3-inst taddcctv #b10 #b100010)
  465.  
  466. (define-f3-inst sub #b10 #b000100)
  467. (define-f3-inst subcc #b10 #b010100)
  468. (define-f3-inst subx #b10 #b001100)
  469. (define-f3-inst subxcc #b10 #b011100)
  470.  
  471. (define-f3-inst tsubcc #b10 #b100001)
  472. (define-f3-inst tsubcctv #b10 #b100011)
  473.  
  474. (define-f3-inst mulscc #b10 #b100100)
  475.  
  476. (define-f3-inst and #b10 #b000001)
  477. (define-f3-inst andcc #b10 #b010001)
  478. (define-f3-inst andn #b10 #b000101)
  479. (define-f3-inst andncc #b10 #b010101)
  480. (define-f3-inst or #b10 #b000010)
  481. (disassem:specialize (or :disassem-control #'look-at-sethi-note) immed)
  482. (define-f3-inst orcc #b10 #b010010)
  483. (define-f3-inst orn #b10 #b000110)
  484. (define-f3-inst orncc #b10 #b010110)
  485. (define-f3-inst xor #b10 #b000011)
  486. (define-f3-inst xorcc #b10 #b010011)
  487. (define-f3-inst xnor #b10 #b000111)
  488. (define-f3-inst xnorcc #b10 #b010111)
  489.  
  490. (define-f3-inst sll #b10 #b100101)
  491. (define-f3-inst srl #b10 #b100110)
  492. (define-f3-inst sra #b10 #b100111)
  493.  
  494. (defun sethi-note (chunk inst stream dstate)
  495.   (when stream
  496.     (let ((sethi-note (disassem:dstate-get-prop dstate 'sethi-note)))
  497.       (when (null sethi-note)
  498.     (setf sethi-note (make-sethi-note)
  499.           (disassem:dstate-get-prop dstate 'sethi-note) sethi-note))
  500.       (setf (sethi-note-target-reg sethi-note)
  501.         (disassem:arg-value 'rd chunk inst))
  502.       (setf (sethi-note-high-bits sethi-note)
  503.         (ash (disassem:arg-value 'immed chunk inst) 10))
  504.       (setf (sethi-note-following-addr sethi-note)
  505.         (disassem:dstate-nextpos dstate)))))
  506.  
  507. (define-instruction (sethi :disassem-control #'sethi-note)
  508.   (format-2-immed (rd :argument reg)
  509.           (op2 :constant #b100)
  510.           (immed :argument (or (unsigned-byte 22) (signed-byte 22))))
  511.   (format-2-immed (rd :argument reg)
  512.           (op2 :constant #b100)
  513.           (immed :argument sethi-fixup)))
  514.  
  515. (define-f3-inst save #b10 #b111100)
  516. (define-f3-inst restore #b10 #b111101)
  517.  
  518. (define-instruction (b)
  519.   (format-2-branch (op :constant #b00)
  520.            (a :constant 0)
  521.            (cond :argument branch-condition)
  522.            (op2 :constant #b010)
  523.            (disp :argument relative-label))
  524.   (format-2-branch (op :constant #b00)
  525.            (a :constant 0)
  526.            (cond :constant branch-cond-true)
  527.            (op2 :constant #b010)
  528.            (disp :argument relative-label)))
  529.  
  530. (define-instruction (ba)
  531.   (format-2-branch (op :constant #b00)
  532.            (a :constant 1)
  533.            (cond :argument branch-condition)
  534.            (op2 :constant #b010)
  535.            (disp :argument relative-label))
  536.   (format-2-branch (op :constant #b00)
  537.            (a :constant 1)
  538.            (cond :constant #b1000)
  539.            (op2 :constant #b010)
  540.            (disp :argument relative-label)))
  541. (disassem:specialize (ba :name 'b))
  542.  
  543. (define-instruction (t
  544.              :disassem-printer '(:name rd :tab immed))
  545.   (format-3-immed (op :constant #b10)
  546.           (rd :argument branch-condition)
  547.           (op3 :constant #b111010)
  548.           (rs1 :constant 0)
  549.           (immed :argument (or (signed-byte 13) (unsigned-byte 13)))))
  550.  
  551. (define-instruction (fb)
  552.   (format-2-branch (op :constant #b00)
  553.            (a :constant 0)
  554.            (cond :argument branch-fp-condition)
  555.            (op2 :constant #b110)
  556.            (disp :argument relative-label)))
  557.  
  558. ;;; slightly complicated to handle both jal and j
  559. (defconstant jal-printer
  560.   '(:name :tab
  561.       (:choose (rs1 (:unless (:constant 0) "+" immed))
  562.            (:cond ((rs2 :constant 0) rs1)
  563.               ((rs1 :constant 0) rs2)
  564.               (t rs1 "+" rs2)))
  565.       (:unless (:constant 0) ", " rd)))
  566.  
  567. (define-instruction (jal :disassem-printer jal-printer)
  568.   (format-3-reg (op :constant #b10)
  569.         (rd :argument reg)
  570.         (op3 :constant #b111000)
  571.         (rs1 :argument reg)
  572.         (rs2 :argument reg))
  573.   (format-3-reg (op :constant #b10)
  574.         (rd :argument reg)
  575.         (op3 :constant #b111000)
  576.         (rs1 :constant 0)
  577.         (rs2 :argument reg))
  578.   (format-3-immed (op :constant #b10)
  579.           (rd :argument reg)
  580.           (op3 :constant #b111000)
  581.           (rs1 :argument reg)
  582.           (immed :argument (signed-byte 13)))
  583.   (format-3-immed (op :constant #b10)
  584.           (rd :argument reg)
  585.           (op3 :constant #b111000)
  586.           (rs1 :argument reg)
  587.           (immed :argument add-fixup)))
  588.  
  589. (disassem:specialize (jal :disassem-control #'look-at-sethi-note)
  590.   immed)
  591.  
  592. (define-instruction (j :disassem-printer jal-printer)
  593.   (format-3-reg (op :constant #b10)
  594.         (rd :constant 0)
  595.         (op3 :constant #b111000)
  596.         (rs1 :argument reg)
  597.         (rs2 :argument reg))
  598.   (format-3-reg (op :constant #b10)
  599.         (rd :constant 0)
  600.         (op3 :constant #b111000)
  601.         (rs1 :argument reg)
  602.         (rs2 :constant 0))
  603.   (format-3-immed (op :constant #b10)
  604.           (rd :constant 0)
  605.           (op3 :constant #b111000)
  606.           (rs1 :argument reg)
  607.           (immed :argument (signed-byte 13)))
  608.   (format-3-immed (op :constant #b10)
  609.           (rd :constant 0)
  610.           (op3 :constant #b111000)
  611.           (rs1 :argument reg)
  612.           (immed :argument add-fixup)))
  613.  
  614. (disassem:specialize (j :disassem-control #'look-at-sethi-note)
  615.   immed)
  616.  
  617. (define-instruction (rdy :disassem-printer '('RD :tab '%Y ", " rd))
  618.   (format-3-immed (op :constant #b10)
  619.           (rd :argument reg)
  620.           (op3 :constant #b101000)
  621.           (rs1 :constant 0)
  622.           (immed :constant 0)))
  623.  
  624. (define-instruction (wry
  625.              :disassem-printer
  626.                  '('WR :tab
  627.                     rs1
  628.                 (:unless (:constant 0) ", " (:choose immed rs2))
  629.                 ", " '%Y))
  630.   (format-3-reg (op :constant #b10)
  631.         (rd :constant 0)
  632.         (op3 :constant #b110000)
  633.         (rs1 :argument reg)
  634.         (rs2 :argument reg))
  635.   (format-3-reg (op :constant #b10)
  636.         (rd :constant 0)
  637.         (op3 :constant #b110000)
  638.         (rs1 :argument reg)
  639.         (rs2 :constant 0))
  640.   (format-3-immed (op :constant #b10)
  641.           (rd :constant 0)
  642.           (op3 :constant #b110000)
  643.           (rs1 :argument reg)
  644.           (immed :argument (signed-byte 13))))
  645.  
  646. ;;; ----------------------------------------------------------------
  647.  
  648. (defun snarf-error-junk (sap offset &optional length-only)
  649.   (let* ((length (system:sap-ref-8 sap offset))
  650.      (vector (make-array length :element-type '(unsigned-byte 8))))
  651.     (declare (type system:system-area-pointer sap)
  652.          (type (unsigned-byte 8) length)
  653.          (type (simple-array (unsigned-byte 8) (*)) vector))
  654.     (cond (length-only
  655.        (values 0 (1+ length) nil nil))
  656.       (t
  657.        (kernel:copy-from-system-area sap (* sparc:byte-bits (1+ offset))
  658.                      vector (* sparc:word-bits
  659.                            sparc:vector-data-offset)
  660.                      (* length sparc:byte-bits))
  661.        (collect ((sc-offsets)
  662.              (lengths))
  663.          (lengths 1)        ; the length byte
  664.          (let* ((index 0)
  665.             (error-number (c::read-var-integer vector index)))
  666.            (lengths index)
  667.            (loop
  668.          (when (>= index length)
  669.            (return))
  670.          (let ((old-index index))
  671.            (sc-offsets (c::read-var-integer vector index))
  672.            (lengths (- index old-index))))
  673.            (values error-number
  674.                (1+ length)
  675.                (sc-offsets)
  676.                (lengths))))))))
  677.  
  678. (defmacro break-cases (breaknum &body cases)
  679.   (let ((bn-temp (gensym)))
  680.     (collect ((clauses))
  681.       (dolist (case cases)
  682.     (clauses `((= ,bn-temp ,(car case)) ,@(cdr case))))
  683.       `(let ((,bn-temp ,breaknum))
  684.      (cond ,@(clauses))))))
  685.  
  686. (defun unimp-control (chunk inst stream dstate)
  687.   (flet ((nt (x) (if stream (disassem:note x dstate))))
  688.     (break-cases (disassem:arg-value 'data chunk inst)
  689.       (vm:error-trap
  690.        (nt "Error trap")
  691.        (disassem:handle-break-args #'snarf-error-junk stream dstate))
  692.       (vm:cerror-trap
  693.        (nt "Cerror trap")
  694.        (disassem:handle-break-args #'snarf-error-junk stream dstate))
  695.       (vm:object-not-list-trap
  696.        (nt "Object not list trap"))
  697.       (vm:breakpoint-trap
  698.        (nt "Breakpoint trap"))
  699.       (vm:pending-interrupt-trap
  700.        (nt "Pending interrupt trap"))
  701.       (vm:halt-trap
  702.        (nt "Halt trap"))
  703.       (vm:function-end-breakpoint-trap
  704.        (nt "Function end breakpoint trap"))
  705.       (vm:object-not-structure-trap
  706.        (nt "Object not structure trap"))
  707.     )))
  708.  
  709. (define-instruction (unimp :disassem-control #'unimp-control)
  710.   (format-2-unimp (data :argument (unsigned-byte 22))))
  711.  
  712. ;;; ----------------------------------------------------------------
  713.  
  714.  
  715. (eval-when (compile eval)
  716.  
  717. (defmacro define-unary-fp-inst (name opf &optional odd)
  718.   (let ((kind (if odd 'odd-fp-reg 'fp-reg)))
  719.     `(define-instruction (,name)
  720.        (format-3-fpop (op :constant #b10)
  721.               (rd :argument ,kind)
  722.               (op3 :constant #b110100)
  723.               (rs1 :argument ,kind)
  724.               (opf :constant ,opf)
  725.               (rs2 :argument ,kind))
  726.        (format-3-fpop (op :constant #b10)
  727.               (rd :argument ,kind)
  728.               (op3 :constant #b110100)
  729.               (rs1 :same-as rd)
  730.               (opf :constant ,opf)
  731.               (rs2 :argument ,kind)))))
  732.  
  733. (defmacro define-binary-fp-inst (name opf &optional (op3 #b110100))
  734.   `(define-instruction (,name)
  735.      (format-3-fpop (op :constant #b10)
  736.             (rd :argument fp-reg)
  737.             (op3 :constant ,op3)
  738.             (rs1 :argument fp-reg)
  739.             (opf :constant ,opf)
  740.             (rs2 :argument fp-reg))
  741.      (format-3-fpop (op :constant #b10)
  742.             (rd :argument fp-reg)
  743.             (op3 :constant ,op3)
  744.             (rs1 :same-as rd)
  745.             (opf :constant ,opf)
  746.             (rs2 :argument fp-reg))))
  747.  
  748. ); eval-when (compile eval)
  749.  
  750. (define-unary-fp-inst fitos #b011000100)
  751. (define-unary-fp-inst fitod #b011001000)
  752. (define-unary-fp-inst fitox #b011001100)
  753.  
  754. (define-unary-fp-inst fstoir #b011000001)
  755. (define-unary-fp-inst fdtoir #b011000010)
  756. (define-unary-fp-inst fxtoir #b011000011)
  757.  
  758. (define-unary-fp-inst fstoi #b011010001)
  759. (define-unary-fp-inst fdtoi #b011010010)
  760. (define-unary-fp-inst fxtoi #b011010011)
  761.  
  762. (define-unary-fp-inst fstod #b011001001)
  763. (define-unary-fp-inst fstox #b011001101)
  764. (define-unary-fp-inst fdtos #b011000110)
  765. (define-unary-fp-inst fdtox #b011001110)
  766. (define-unary-fp-inst fxtos #b011000111)
  767. (define-unary-fp-inst fxtod #b011001011)
  768.  
  769. (define-unary-fp-inst fmovs #b000000001)
  770. (define-unary-fp-inst fmovs-odd #b000000001 t)
  771. (define-unary-fp-inst fnegs #b000000101)
  772. (define-unary-fp-inst fabss #b000001001)
  773.  
  774. (define-unary-fp-inst fsqrts #b000101001)
  775. (define-unary-fp-inst fsqrtd #b000101010)
  776. (define-unary-fp-inst fsqrtx #b000101011)
  777.  
  778.  
  779. (define-binary-fp-inst fadds #b001000001)
  780. (define-binary-fp-inst faddd #b001000010)
  781. (define-binary-fp-inst faddx #b001000011)
  782. (define-binary-fp-inst fsubs #b001000101)
  783. (define-binary-fp-inst fsubd #b001000110)
  784. (define-binary-fp-inst fsubx #b001000111)
  785.  
  786. (define-binary-fp-inst fmuls #b001001001)
  787. (define-binary-fp-inst fmuld #b001001010)
  788. (define-binary-fp-inst fmulx #b001001011)
  789. (define-binary-fp-inst fdivs #b001001101)
  790. (define-binary-fp-inst fdivd #b001001110)
  791. (define-binary-fp-inst fdivx #b001001111)
  792.  
  793. (define-binary-fp-inst fcmps #b001010001 #b110101)
  794. (define-binary-fp-inst fcmpd #b001010010 #b110101)
  795. (define-binary-fp-inst fcmpx #b001010011 #b110101)
  796. (define-binary-fp-inst fcmpes #b001010101 #b110101)
  797. (define-binary-fp-inst fcmped #b001010110 #b110101)
  798. (define-binary-fp-inst fcmpex #b001010111 #b110101)
  799.  
  800.  
  801.  
  802.  
  803. ;;;; Pseudo-instructions, etc.
  804.  
  805. (define-pseudo-instruction li 64 (reg value)
  806.   (etypecase value
  807.     ((signed-byte 13)
  808.      (inst add reg zero-tn value))
  809.     ((or (signed-byte 32) (unsigned-byte 32))
  810.      (let ((hi (ldb (byte 22 10) value))
  811.        (lo (ldb (byte 10 0) value)))
  812.        (inst sethi reg hi)
  813.        (unless (zerop lo)
  814.      (inst add reg lo))))
  815.     (fixup
  816.      (inst sethi reg value)
  817.      (inst add reg value))))
  818.  
  819. ;;; Jal to a full 32-bit address.  Tmpreg is trashed.
  820. (define-pseudo-instruction jali 64 (link tmpreg value)
  821.   (etypecase value
  822.     ((signed-byte 13)
  823.      (inst jal link zero-tn value))
  824.     ((or (signed-byte 32) (unsigned-byte 32))
  825.      (let ((hi (ldb (byte 22 10) value))
  826.        (lo (ldb (byte 10 0) value)))
  827.        (inst sethi tmpreg hi)
  828.        (inst jal link tmpreg lo)))
  829.     (fixup
  830.      (inst sethi tmpreg value)
  831.      (inst jal link tmpreg value))))
  832.  
  833. ;;; Jump to a full 32-bit address.  Tmpreg is trashed.
  834. (define-pseudo-instruction ji 64 (tmpreg value)
  835.   (inst jali zero-tn tmpreg value))
  836.  
  837. (define-instruction (nop :disassem-printer '(:name))
  838.   (format-2-immed (rd :constant 0)
  839.           (op2 :constant #b100)
  840.           (immed :constant 0)))
  841.  
  842. (define-instruction (cmp
  843.              :disassem-printer
  844.                  '(:name :tab rs1 ", " (:choose immed rs2)))
  845.   (format-3-reg (op :constant #b10)
  846.         (rd :constant 0)
  847.         (op3 :constant #b010100)
  848.         (rs1 :argument reg)
  849.         (rs2 :argument reg))
  850.   (format-3-reg (op :constant #b10)
  851.         (rd :constant 0)
  852.         (op3 :constant #b010100)
  853.         (rs1 :argument reg)
  854.         (rs2 :constant 0))
  855.   (format-3-immed (op :constant #b10)
  856.           (rd :constant 0)
  857.           (op3 :constant #b010100)
  858.           (rs1 :argument reg)
  859.           (immed :argument (signed-byte 13))))
  860.  
  861. (define-instruction (not
  862.              :disassem-printer
  863.              '(:name :tab (:unless (:same-as rd) rs1 ", " ) rd))
  864.   (format-3-reg (op :constant #b10)
  865.         (rd :argument reg)
  866.         (op3 :constant #b000111)
  867.         (rs1 :argument reg)
  868.         (rs2 :constant 0))
  869.   (format-3-reg (op :constant #b10)
  870.         (rd :argument reg)
  871.         (op3 :constant #b000111)
  872.         (rs1 :same-as rd)
  873.         (rs2 :constant 0)))
  874.  
  875. (define-instruction (neg
  876.              :disassem-printer
  877.              '(:name :tab (:unless (:same-as rd) rs2 ", " ) rd))
  878.   (format-3-reg (op :constant #b10)
  879.         (rd :argument reg)
  880.         (op3 :constant #b000100)
  881.         (rs1 :constant 0)
  882.         (rs2 :argument reg))
  883.   (format-3-reg (op :constant #b10)
  884.         (rd :argument reg)
  885.         (op3 :constant #b000100)
  886.         (rs1 :constant 0)
  887.         (rs2 :same-as rd)))
  888.  
  889. (define-instruction (move :disassem-printer '(:name :tab rs2 ", " rd))
  890.   (format-3-reg (op :constant #b10)
  891.         (rd :argument reg)
  892.         (op3 :constant #b000010)
  893.         (rs1 :constant 0)
  894.         (rs2 :argument reg)))
  895.  
  896.  
  897. ;;; Instructions for dumping data and header objects.
  898.  
  899. (define-format (word-format 32)
  900.   (data (byte 32 0)))
  901. (define-instruction (word)
  902.   (word-format (data :argument (or (unsigned-byte 32) (signed-byte 32)))))
  903.  
  904. (define-format (short-format 16)
  905.   (data (byte 16 0)))
  906. (define-instruction (short)
  907.   (short-format (data :argument (or (unsigned-byte 16) (signed-byte 16)))))
  908.  
  909. (define-format (byte-format 8)
  910.   (data (byte 8 0)))
  911. (define-instruction (byte)
  912.   (byte-format (data :argument (or (unsigned-byte 8) (signed-byte 8)))))
  913.  
  914.  
  915. (define-format (header-object 32)
  916.   (type (byte 8 0))
  917.   (data (byte 24 8)
  918.     :default 0
  919.     :function (lambda (ignore)
  920.             (declare (ignore ignore))
  921.             (ash (+ *current-position* (component-header-length))
  922.              (- vm:word-shift)))))
  923.  
  924. (define-instruction (function-header-word)
  925.   (header-object (type :constant vm:function-header-type)))
  926.  
  927. (define-instruction (lra-header-word)
  928.   (header-object (type :constant vm:return-pc-header-type)))
  929.  
  930.  
  931.  
  932. ;;;; Instructions for converting between code objects, functions, and lras
  933.  
  934. (eval-when (compile eval)
  935.  
  936. (defmacro define-compute-instruction (name calculation)
  937.   (let ((add (symbolicate name "-ADD"))
  938.     (sethi (symbolicate name "-SETHI"))
  939.     (or (symbolicate name "-OR")))
  940.     `(progn
  941.        (define-instruction (,add)
  942.      (format-3-immed
  943.       (op :constant #b10)
  944.       (rd :argument reg)
  945.       (op3 :constant #b000000)
  946.       (rs1 :argument reg)
  947.       (immed :argument label
  948.          :function (lambda (label)
  949.                  (let ((result ,calculation))
  950.                    (assert (typep result '(signed-byte 13)))
  951.                    result)))))
  952.        (define-instruction (,sethi)
  953.      (format-2-immed (rd :argument reg)
  954.              (op2 :constant #b100)
  955.              (immed :argument label
  956.                 :function (lambda (label)
  957.                         (ash ,calculation -10)))))
  958.        (define-instruction (,or)
  959.      (format-3-immed (op :constant #b10)
  960.              (rd :argument reg)
  961.              (op3 :constant #b000010)
  962.              (rs1 :same-as rd)
  963.              (immed :argument label
  964.                 :function (lambda (label)
  965.                         (logand ,calculation
  966.                             (1- (ash 1 10)))))))
  967.        (define-pseudo-instruction ,name 96 (dst src label temp)
  968.      (cond ((typep ,calculation '(signed-byte 13))
  969.         (inst ,add dst src label))
  970.            (t
  971.         (inst ,sethi temp label)
  972.         (inst ,or temp label)
  973.         (inst add dst src temp)))))))
  974.  
  975. ); eval-when (compile eval)
  976.  
  977.  
  978. ;; code = fn - fn-ptr-type - header - label-offset + other-pointer-tag
  979. (define-compute-instruction compute-code-from-fn
  980.                 (- vm:other-pointer-type
  981.                    vm:function-pointer-type
  982.                    (label-position label)
  983.                    (component-header-length)))
  984.  
  985. ;; code = lra - other-pointer-tag - header - label-offset + other-pointer-tag
  986. (define-compute-instruction compute-code-from-lra
  987.                 (- (+ (label-position label)
  988.                   (component-header-length))))
  989.  
  990. ;; lra = code + other-pointer-tag + header + label-offset - other-pointer-tag
  991. (define-compute-instruction compute-lra-from-code
  992.                 (+ (label-position label)
  993.                    (component-header-length)))
  994.  
  995.